home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1995 November / Macworld Nov ’95.toast / Developers / Selection ƒ 2.5 / popup < prev    next >
Encoding:
Text File  |  1994-11-06  |  4.2 KB  |  201 lines  |  [TEXT/MSET]
  1.  \ 28Oct94 dbh updated to 2.5 syntax 
  2.     \ note, need to respond to deactivate:/activate:
  3.  
  4. (*
  5.  
  6. Class popup allows us to easily have popup menus in a selwindow by following
  7. our standard selection protocol.  Popups are subclassed from the standard Mops
  8. menu class so storing xts for the popup to execute is just like for standard
  9. menus.  One unique feature of the popup class is we need not specify a menu
  10. ID because the new: method will simply choose a unique ID for us, we don't
  11. care which.
  12.  
  13. These popups are not resource-based.
  14.  
  15. Also, in keeping with our philosophy that a minimum, preferably no, setup
  16. should be required to use our objects, class popup will function quite
  17. nicely simply by instantiating and adding to our selwindow.
  18.  
  19. *)
  20.  
  21.  
  22. :class popup super{ menu nullselect }
  23.     bool alive
  24.     rect+ popupbox
  25.     text16 title    \ font will be contained in the title
  26.     rect+ titlebox
  27.     int currentitem#
  28.     32 $x itemList$    \ we limit the initial string sizes to a total of 32
  29.                     \ but we can add all we want after new: of course
  30.  
  31. :m init:    ( ... xts ... n -- )
  32.     put: super ;m
  33.  
  34. :m get:  ( -- n)    \ will return the 0-based index of the currently
  35.                     \ selected menu item
  36.     get: currentitem# ;m
  37.  
  38. :m settitle: ( addr len -- )
  39.     put: title ;m
  40.  
  41. :m setItemList:  ( addr len -- )
  42.     put: itemList$ ;m
  43.  
  44. :m classinit:
  45.     clear: alive
  46.     " Chicago" fontname: title
  47.     12 fontsize: title
  48.     " popup" settitle: self
  49.     0 put: currentitem#
  50.     " item0" setItemList: self
  51.     limit 0 DO
  52.         ['] null LOOP limit
  53.     init: self
  54.     ;m
  55.  
  56. :m hit?: \ ( -- b )
  57.     where: theMouse
  58.     popupbox PtinRect ;m
  59.  
  60. :m del:
  61.     \ draw the del
  62.     getx2: popupbox  14 -  ( x)
  63.     gety2: popupbox  9 -   ( y)  MoveTo
  64.     del ;m
  65.  
  66.  
  67. :m drawMenuItem:
  68.     set: title    \ sets our font
  69.     Call PenNormal    \ just in case!
  70.     1 1 inset: popupbox
  71.     clear: popupbox
  72.     -1 -1 inset: popupbox
  73.     \ now draw the text in the box, it will be the current item text
  74.     getx1: popupbox  4 + ( x)
  75.     gety1: popupbox  13 + ( y)  MoveTo
  76.     get: currentitem# getitem: super mDrawString
  77.     del: self
  78.     ;m
  79.  
  80. :m draw:
  81.     call PenNormal
  82.     dropshadow: popupbox
  83.     drawMenuItem: self
  84.     
  85.     \ and finally, the title
  86.     getx1: titlebox  ( x)
  87.     gety1: titlebox  12 +   ( y)  MoveTo
  88.     draw: title
  89.     ;m
  90.  
  91. :m click:    { \ olditem newitem -- }
  92.     invert: titlebox
  93.     get: currentitem#  -> olditem
  94.     0    \ room for result
  95.     get: mhndl
  96.     topint: popupbox  \ a packed point
  97.     l->g  unpack swap pack  \ top, left
  98.     get: currentitem# 1 + makeint    \ PopUpItem
  99.     call PopUpMenuSelect
  100.     unpack drop 1 - -> newitem \ our item#, 1 less than toolbox's
  101.     
  102.     newitem  0>=
  103.     IF
  104.         olditem uncheck: super
  105.         newitem check: super
  106.         newitem put: currentitem#
  107.         newitem exec: [self] \ 03Sep94 dbh late bind so subclasses can be different
  108.         normal: super
  109.         drawMenuItem: self
  110.     THEN
  111.     invert: titlebox
  112.     ;m
  113.  
  114. :m titlewidth: ( -- w)
  115.     word0 get$: title call StringWidth i->l    ;m
  116.  
  117. private
  118. :m resize:    { \ wid -- }
  119.     get: alive not IF exit THEN
  120.     get: mhndl call CalcMenuSize    \ this will set the tbox record sizes
  121.     get: mhndl @ 2 + w@ ( width ) 18 ( height)  \ get the tbox record size
  122.     setsize: popupbox                    \ and set our rect size to match
  123.     
  124.     \ finally, set up our title box to the correct position and size
  125.     get: popupbox  put: titlebox
  126.     titlewidth: self -> wid
  127.     wid  setwidth: titlebox
  128.     wid 1 + negate 0 move: titlebox
  129.     0 -3 stretch: titlebox
  130.     ;m
  131. public    
  132.  
  133. :m new:  { wptr -- }
  134.     \ don't need wptr, but must follow select protocol
  135.  
  136.     id: menuList put: resid    \ automatically assign an ID, we don't care which
  137.     
  138.     getnew: title
  139.     
  140.     get: title new: super    \ now it's a toolbox menu
  141.     set: alive    \ mark as alive so resize: will function
  142.     
  143.     get: itemList$ add: super    \ append our item(s)
  144.     
  145.     resize: self
  146.     
  147.     get: mhndl -1 makeint call InsertMenu    \ -1 indicates a popup
  148.     
  149.     get: currentitem# check: super
  150.     
  151.     ;m
  152.  
  153. :m add:    ( addr len -- )
  154.     add: super
  155.     resize: self ;m
  156.  
  157. :m release:
  158.     release: super
  159.     clear: alive ;m
  160.  
  161. :m move: { dx dy -- }
  162.     dx dy move: titleBox
  163.     dx dy move: popupbox
  164.     resize: self
  165.     ;m
  166.  
  167. :m moveto: { x y -- }
  168.     x y moveto: titleBox
  169.     x y moveto: popupbox
  170.     resize: self
  171.     ;m
  172.  
  173. ;class
  174.  
  175. endload
  176.  
  177. *** EXAMPLE USE
  178.  
  179. selwindow ww
  180. test: ww
  181.  
  182. 4 popup pp
  183. " item0;item1;item2;item3" setItemList: pp
  184. 100 100 moveto: pp
  185. pp add: ww
  186.  
  187. : noise 1 beep ;
  188.  
  189. xts{ noise null noise null } init: pp
  190.  
  191. 3 popup pp2
  192. 75 50 moveto: pp2
  193. " Transp:" settitle: pp2
  194. " Trains;Boats;Planes" setItemList: pp2
  195. pp2 add: ww
  196.  
  197.  
  198. pushButton bb
  199. 100 75 moveto: bb
  200. bb add: ww
  201.